home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0487.arc / TELLO.ARC / PUZZLE.LSP < prev    next >
Encoding:
Text File  |  1980-01-01  |  3.4 KB  |  130 lines
  1. ; PUZZLE
  2.  
  3. (defconstant size 511.)
  4. (defconstant classmax 3.)
  5. (defconstant typemax 12.)
  6.  
  7. (defconstant true t)
  8. (defconstant false ())
  9.  
  10. (defvar iii 0)
  11. (defvar kount 0)
  12. (defvar *d* 8.)
  13.  
  14. (defvar piececount (make-array (1+ classmax) ':initial-element 0))
  15. (defvar class (make-array (1+ typemax) ':initial-element 0))
  16. (defvar piecemax (make-array (1+ typemax) ':initial-element 0))
  17. (defvar puzzle (make-array (1+ size)))
  18. (defvar *p* (make-array (list (1+ typemax) (1+ size))))
  19.  
  20. (defun fit (i j)
  21.   (let ((end (aref piecemax i)))
  22.     (do ((k 0 (1+ k)))
  23.     ((> k end) true)
  24.       (cond ((aref *p* i k)
  25.          (cond ((aref puzzle (+ j k))
  26.             (return false))))))))
  27.  
  28.  
  29. (defun place (i j)
  30.   (let ((end (aref piecemax i)))
  31.     (do ((k 0 (1+ k)))
  32.     ((> k end))
  33.       (cond ((aref *p* i k)
  34.          (setf (aref puzzle (+ j k)) true))))
  35.     (setf (aref piececount (aref class i)) (- (aref piececount (aref class i)) 1))
  36.     (do ((k j (1+ k)))
  37.     ((> k size)
  38.     
  39. ;         (terpri)
  40. ;         (princ "Puzzle filled")
  41.     
  42.      0)
  43.       (cond ((not (aref puzzle k))
  44.                (return k))))))
  45.  
  46. (defun puzzle-remove (i j)
  47.   (let ((end (aref piecemax i)))
  48.     (do ((k 0 (1+ k)))
  49.     ((> k end))
  50.       (cond ((aref *p* i k) (setf (aref puzzle (+ j k)) false))))
  51.       (setf (aref piececount (aref class i)) (+ (aref piececount (aref class i)) 1))))
  52.  
  53. (defun trial (j)
  54.   (let ((k 0))
  55.     (do ((i 0 (1+ i)))
  56.     ((> i typemax) (setq kount (1+ kount)) false)
  57.       (cond ((not (= (aref piececount (aref class i)) 0))
  58.          (cond ((fit i j)
  59.             (setq k (place i j))
  60.             (cond ((or (trial k)
  61.                    (= k 0))
  62. ;               (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1))
  63.                (setq kount (+ kount 1))
  64.                (return true))
  65.               (t (puzzle-remove i j))))))))))
  66.  
  67. (defun definepiece (iclass ii jj kk)
  68.   (let ((index 0))
  69.     (do ((i 0 (1+ i)))
  70.     ((> i ii))
  71.       (do ((j 0 (1+ j)))
  72.       ((> j jj))
  73.     (do ((k 0 (1+ k)))
  74.         ((> k kk))
  75.       (setq index  (+ i (* *d* (+ j (* *d* k)))))
  76.       (setf (aref *p* iii index) true))))
  77.     (setf (aref class iii) iclass)
  78.     (setf (aref piecemax iii) index)
  79.     (cond ((not (= iii typemax))
  80.        (setq iii (+ iii 1))))))
  81.  
  82. (defun start ()
  83.   (do ((m 0 (1+ m)))
  84.       ((> m size))
  85.     (setf (aref puzzle m) true))
  86.   (do ((i 1 (1+ i)))
  87.       ((> i 5))
  88.     (do ((j 1 (1+ j)))
  89.     ((> j 5))
  90.       (do ((k 1 (1+ k)))
  91.       ((> k 5))
  92.     (setf (aref puzzle (+ i (* *d* (+ j (* *d* k))))) false))))
  93.   (do ((i 0 (1+ i)))
  94.       ((> i typemax))
  95.     (do ((m 0 (1+ m)))
  96.     ((> m size))
  97.       (setf (aref *p* i m) false)))
  98.   (setq iii 0)
  99.   (definePiece 0 3 1 0)
  100.   (definePiece 0 1 0 3)
  101.   (definePiece 0 0 3 1)
  102.   (definePiece 0 1 3 0)
  103.   (definePiece 0 3 0 1)
  104.   (definePiece 0 0 1 3)
  105.  
  106.   (definePiece 1 2 0 0)
  107.   (definePiece 1 0 2 0)
  108.   (definePiece 1 0 0 2)
  109.  
  110.   (definePiece 2 1 1 0)
  111.   (definePiece 2 1 0 1)
  112.   (definePiece 2 0 1 1)
  113.  
  114.   (definePiece 3 1 1 1)
  115.  
  116.   (setf (aref pieceCount 0) 13.)
  117.   (setf (aref pieceCount 1) 3)
  118.   (setf (aref pieceCount 2) 1)
  119.   (setf (aref pieceCount 3) 1)
  120.   (let ((m (+ 1 (* *d* (+ 1 *d*))))
  121.     (n 0)(kount 0))
  122.     (cond ((fit 0 m) (setq n (place 0 m)))
  123.       (t (format t "~%Error.")))
  124.     (cond ((trial n)
  125.        (format t "~%Success in ~4D trials." kount))
  126.       (t (format t "~%Failure.")))))
  127.  
  128. (define-timer puzzle "Puzzle" (start))
  129. (qa-attempt "Puzzle" (start) nil)
  130.